home *** CD-ROM | disk | FTP | other *** search
GW-BASIC | 1986-11-30 | 4.5 KB | 157 lines
100 REM ALPHAMAR Program. 110 REM Prints an Alphabetic List of Marriages 120 REM By: Melvin O. Duke. Last Updated 17 February 1986. 200 REM Screen Definitions 210 WIDTH "scrn:", 80 220 SCREEN S1,S2,S3,S4 600 REM Titles 610 TITLE$ = "Alphabetic List of Marriages" 620 TITLE$ = TITLE$ + " ON DISPLAY" 700 REM Terminate if not called from the Menu 710 IF DD.MENU$ <> "" THEN 770 720 COLOR 7,0 : KEY ON : CLS : LOCATE 15,1 730 PRINT "Cannot run the" 740 PRINT TITLE$ 750 PRINT "Program, unless selected from the MENU" 760 END 770 REM OK 900 REM Dimension Statements 910 DIM PERS.ID(2*MAX.MAR), MARR.ID(2*MAX.MAR), IDX$(2*MAX.MAR) 1000 REM Produce the first screen 1010 KEY ON : CLS : KEY OFF 1020 REM Draw the outer double box 1030 R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300 1040 REM Find the title location 1050 TITLE.POS = 40 - INT(LEN(TITLE$)/2) 1060 REM Draw the title box 1070 R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500 1080 REM Print the title 1090 LOCATE 4,TITLE.POS : PRINT TITLE$ 1100 LOCATE 5,40-INT(LEN(VERSION$)/2) : PRINT VERSION$; 1230 REM Draw the Copyright box 1240 R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300 1250 REM Print the Copyright 1260 LOCATE 20,40-INT(LEN(COPY1$)/2) : PRINT COPY1$; 1270 LOCATE 21,40-INT(LEN(COPY2$)/2) : PRINT COPY2$; 1280 GOTO 1700 1300 REM subroutine to print a double box 1310 COLOR P 1320 FOR I = R1 + 1 TO R2 - 1 1330 LOCATE I, C1 : PRINT CHR$(186); 1340 LOCATE I, C2 : PRINT CHR$(186); 1350 NEXT I 1360 FOR J = C1 + 1 TO C2 - 1 1370 LOCATE R1, J : PRINT CHR$(205); 1380 LOCATE R2, J : PRINT CHR$(205); 1390 NEXT J 1400 LOCATE R1, C1 : PRINT CHR$(201); 1410 LOCATE R1, C2 : PRINT CHR$(187); 1420 LOCATE R2, C1 : PRINT CHR$(200); 1430 LOCATE R2, C2 : PRINT CHR$(188); 1440 COLOR W 1450 RETURN 1500 REM subroutine to print a single box 1510 COLOR B 1520 FOR I = R1 + 1 TO R2 - 1 1530 LOCATE I, C1 : PRINT CHR$(179); 1540 LOCATE I, C2 : PRINT CHR$(179); 1550 NEXT I 1560 FOR J = C1 + 1 TO C2 - 1 1570 LOCATE R1, J : PRINT CHR$(196); 1580 LOCATE R2, J : PRINT CHR$(196); 1590 NEXT J 1600 LOCATE R1, C1 : PRINT CHR$(218); 1610 LOCATE R1, C2 : PRINT CHR$(191); 1620 LOCATE R2, C1 : PRINT CHR$(192); 1630 LOCATE R2, C2 : PRINT CHR$(217); 1640 COLOR W 1650 RETURN 1700 REM ask user to press a key to continue 1710 LOCATE 25,1 1720 PRINT "Have Data Diskette(s) in Place, then Press any key to continue."; 1730 K$ = INKEY$ : IF K$ = "" THEN 1730 1740 KEY ON : CLS : KEY OFF 2000 REM ALPHAMAR Program Starts Here. 2010 OPEN DD.PERS$+"persfile" AS #1 LEN = 256 2020 FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$ 2030 REM Read the Marriage Index and then the Person File 2040 KEY ON : CLS : KEY OFF 2050 OPEN DD.MARIDX$+"mindex" FOR INPUT AS #2 2060 INPUT #2, C 2070 LOCATE 19,1 : PRINT "There are:";C;"Marriage Index Records" 2080 FOR I = 1 TO C 2090 INPUT #2, PERS.ID(I), MARR.ID(I) 2100 LOCATE 23,1 : PRINT "Processing Marriage Index Record:";I,"Freespace";FRE(0) 2110 REM get the personal information 2120 GET #1, PERS.ID(I) 2130 REM Extract information from the file for use 2140 T2$ = F2$ 2150 FOR J = 1 TO LEN(F2$) -1 2160 IF RIGHT$(T2$,1)=" " THEN T2$=LEFT$(T2$,LEN(T2$)-1) ELSE J=LEN(F2$)-1 2170 NEXT J 2180 T3$ = F3$ 2190 FOR J = 1 TO LEN(F3$) -1 2200 IF RIGHT$(T3$,1)=" " THEN T3$=LEFT$(T3$,LEN(T3$)-1) ELSE J=LEN(F3$)-1 2210 NEXT J 2220 IDX$(I) = T2$+T3$ 2230 NEXT I 2240 LOCATE 23,1 : PRINT SPACE$(79) 2250 REM Sort the index into ascending sequence 2260 REM 2270 FOR I = 1 TO 6 2280 B(I) = B(I-1)*4+1 2290 IF B(I) <= C/2 THEN K1 = I 2300 NEXT I 2310 B(K1) = INT(C/5)+1 2320 B(1) = 1 2330 FOR I = K1 TO 1 STEP -1 2340 LOCATE 23,1 : PRINT "Sorting Group:";I 2350 K1 = B(I) 2360 FOR J = K1 TO C 2370 LOCATE 23,20 : PRINT "J:";J; 2380 K2$ = IDX$(J) : TEMP1 = PERS.ID(J) : TEMP2 = MARR.ID(J) 2390 FOR K = J-K1 TO 0 STEP -K1 2400 LOCATE 23,30 : PRINT "K:";K, "Freespace:";FRE(0) 2410 IF K2$ > IDX$(K) THEN 2440 2420 IDX$(K+K1)=IDX$(K): PERS.ID(K+K1)=PERS.ID(K): MARR.ID(K+K1)=MARR.ID(K) 2430 NEXT K 2440 IDX$(K+K1)=K2$: PERS.ID(K+K1)=TEMP1: MARR.ID(K+K1)=TEMP2 2450 NEXT J 2460 NEXT I 2470 LOCATE 21,1 : PRINT "Printing the Alphabetical List" 2480 GOSUB 2500 2490 GOTO 2550 2500 LPRINT " Alphabetic Listing of the Marriages File ";DATE$;" ";TIME$ 2510 LPRINT 2520 LPRINT " REC SURNAME GIVEN-NAMES";TAB(62);"BIRTHDATE" 2530 LPRINT " --- ------- -----------";TAB(62);"---------" 2540 RETURN 2550 REM Read all records, and print the actual ones 2560 K = 0 2570 LOCATE 24,1 : PRINT SPACE$(79); 2580 LOCATE 23,1 : PRINT SPACE$(79); 2590 FOR I = 1 TO C 2600 GET #1, ABS(PERS.ID(I)) 2610 LOCATE 23,1 : PRINT "Printing Record:"; I, "Freespace:";FRE(0) 2620 REM Print the information in Alphabetical Order. 2630 T1 = CVS(F1$) 2640 IF T1 < 1 THEN 2720 2650 K = K + 1 2660 T2$ = F2$ 2670 T3$ = F3$ 2680 T8$ = F8$ 2690 LPRINT USING "#####";MARR.ID(I); 2700 LPRINT TAB(10); T2$; " "; T3$; TAB(62); T8$ 2710 IF K MOD 55 = 0 THEN LPRINT FORM.FEED$;: GOSUB 2500 2720 NEXT I 2730 LPRINT FORM.FEED$; 2740 KEY ON : CLS : KEY OFF 2750 LOCATE 24,1 : PRINT "y (yes) or n (no)"; 2760 LOCATE 23,1 : INPUT "Would you like another copy"; REPLY$ 2770 IF LEFT$(REPLY$,1) = "y" OR LEFT$(REPLY$,1) = "Y" THEN 2470 2780 CLOSE #1 2790 CLOSE #2 2800 KEY ON : CLS : KEY OFF : LOCATE 21,1 2810 PRINT "End of Program 2820 RUN DD.MENU$+"menu" 
(.txt)